Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue43/comcorn/AxDocs.pas

Pascal/Delphi Source File | 1999-02-12 | 17.1 KB | 558 lines

{*******************************************************}
{                                                       }
{       ActiveX Document Support Unit                   }
{       Copyright (c) 1999, Steve Teixeira              }
{                                                       }
{*******************************************************}

unit AxDocs;

interface

uses
  Windows, ComObj, ActiveX, AxCtrls, Controls, Classes, Menus, Messages;

type
  TActiveXDocumentFactory = class;

  TActiveXDocument = class(TActiveXControl, IOleDocument, IOleDocumentView,
    IOleInPlaceActiveObject, IOleInPlaceObject)
  private
    FFactory: TActiveXDocumentFactory;
    FMenu: TMainMenu;
    FOleMenu: HMENU;
    FSharedMenu: HMENU;
    function GetAncestorValueByField(FieldNum: Cardinal): Cardinal;
    procedure SetAncestorValueByField(FieldNum, Value: Cardinal);
    function GetOleInPlaceSite: IOleInPlaceSite;
    procedure SetOleInPlaceSite(const Value: IOleInPlaceSite);
    procedure InPlaceMenuCreate;
    procedure InPlaceMenuDestroy;
    procedure MergeMenus(SharedMenu, SourceMenu: HMENU;
      MenuWidths: PInteger; WidthIndex: Integer);
    procedure UnmergeMenus(SharedMenu, SourceMenu: HMENU);
  protected
    { IOleDocument methods }
    function CreateView(Site: IOleInPlaceSite; Stream: IStream; rsrvd: DWORD;
      out View: IOleDocumentView):HResult; stdcall;
    function GetDocMiscStatus(var Status: DWORD):HResult; stdcall;
    function EnumViews(out Enum: IEnumOleDocumentViews;
      out View: IOleDocumentView):HResult; stdcall;
    { IOleDocumentView methods }
    function SetInPlaceSite(Site: IOleInPlaceSite): HResult; stdcall;
    function GetInPlaceSite(out Site: IOleInPlaceSite): HResult; stdcall;
    function GetDocument(out P: IUnknown): HResult; stdcall;
    function SetRect(const View: TRECT): HResult; stdcall;
    function GetRect(var View: TRECT): HResult; stdcall;
    function SetRectComplex(const View, HScroll, VScroll, SizeBox): HResult; stdcall;
    function Show(fShow: BOOL): HResult; stdcall;
    function UIActivate(fUIActivate: BOOL): HResult; stdcall;
    function Open: HResult; stdcall;
    function CloseView(dwReserved: DWORD): HResult; stdcall;
    function SaveViewState(pstm: IStream): HResult; stdcall;
    function ApplyViewState(pstm: IStream): HResult; stdcall;
    function Clone(NewSite: IOleInPlaceSite; out NewView: IOleDocumentView):HResult; stdcall;
    { IOleInPlaceActiveObject }
    function OnDocWindowActivate(fActivate: BOOL): HResult; stdcall;
    { IOleInPlaceObject }
    function InPlaceDeactivate: HResult; stdcall;
    { Overrides }
    procedure GetDocUIInfo(var Menu: TMainMenu);
    function InPlaceActivate(ActivateUI: Boolean): HResult; override;
    procedure WndProc(var Message: TMessage); override;
  public
    procedure Initialize; override;
    function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
    property Menu: TMainMenu read FMenu write FMenu;
    property OleInPlaceSite: IOleInPlaceSite read GetOleInPlaceSite write SetOleInPlaceSite;
  end;

  TActiveXDocClass = class of TActiveXDocument;

  TActiveXDocumentFactory = class(TActiveXControlFactory)
  private
    FDocMiscStatus: DWORD;
    FHandler: string;
  public
    property DocMiscStatus: DWORD read FDocMiscStatus;
    constructor Create(ComServer: TComServerObject;
      ActiveXDocClass: TActiveXDocClass; WinControlClass: TWinControlClass;
      const ClassID: TGUID; ToolboxBitmapID, MiscStatus: Integer;
      ThreadingModel: TThreadingModel; const Handler: string;
      DocMiscStatus: DWORD);
    procedure UpdateRegistry(Register: Boolean); override;
  end;

implementation

uses ComServ, SysUtils, Forms;

{ TActiveXDocument }

function TActiveXDocument.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
begin
  // Must stub out IOleLink, or container will assume this is a linked object
  // rather than an embedded object.
  if IsEqualGuid(IID, IOleLink) then Result := E_NOINTERFACE
  else Result := inherited ObjQueryInterface(IID, Obj);
end;

function TActiveXDocument.GetOleInPlaceSite: IOleInPlaceSite;
begin
  // Work around fact that FOleInPlaceSite is private in TActiveXControl
  // Note: this work around only guaranteed to work in Delphi 4
  Result := IOleInPlaceSite(GetAncestorValueByField(9));
end;

procedure TActiveXDocument.SetOleInPlaceSite(const Value: IOleInPlaceSite);
begin
  // Work around fact that FOleInPlaceSite is private in TActiveXControl
  // Note: this work around only guaranteed to work in Delphi 4
  SetAncestorValueByField(9, Cardinal(Value));
end;

function TActiveXDocument.GetAncestorValueByField(FieldNum: Cardinal): Cardinal;
var
  ParentInstanceSize, Ofs: Cardinal;
begin
  // Nasty hack: this method returns the value of a particular field in the
  // ancestor class, with the assumption that the given field and all prior
  // fields are 4 bytes in size.
  ParentInstanceSize := ClassParent.ClassParent.InstanceSize;
  Ofs := ParentInstanceSize + ((FieldNum - 1) * 4);
  asm
    mov eax, Self
    add eax, Ofs
    mov eax, dword ptr [eax]
    mov @Result, eax
  end;
end;

procedure TActiveXDocument.SetAncestorValueByField(FieldNum, Value: Cardinal);
var
  ParentInstanceSize, Ofs: Cardinal;
begin
  // Nasty hack: this method sets the value of a particular field in the
  // ancestor class, with the assumption that the given field and all prior
  // fields are 4 bytes in size.
  ParentInstanceSize := ClassParent.ClassParent.InstanceSize;
  Ofs := ParentInstanceSize + ((FieldNum - 1) * 4);
  asm
    mov eax, Self
    add eax, Ofs
    mov ecx, Value
    mov dword ptr [eax], ecx
  end;
end;

procedure TActiveXDocument.Initialize;
begin
  inherited Initialize;
  FFactory := Factory as TActiveXDocumentFactory;
end;

procedure TActiveXDocument.GetDocUIInfo(var Menu: TMainMenu);
begin
  Menu := nil;
end;

function TActiveXDocument.InPlaceActivate(ActivateUI: Boolean): HResult;
begin
  Result := inherited InPlaceActivate(ActivateUI);
  InPlaceMenuCreate;
end;

procedure TActiveXDocument.WndProc(var Message: TMessage);
begin
  inherited WndProc(Message);
  if Message.Msg = WM_LBUTTONDBLCLK then InPlaceActivate(True);
end;

procedure TActiveXDocument.InPlaceMenuCreate;
var
  IPFrame: IOleInPlaceFrame;
  IPSite: IOleInPlaceSite;
  IPUIWindow: IOleInPlaceUIWindow;
  omgw: TOleMenuGroupWidths;
  FrameInfo: TOleInPlaceFrameInfo;
  PosRect, ClipRect: TRect;
begin
  OleCheck(ClientSite.QueryInterface(IOleInPlaceSite, IPSite));
  FrameInfo.cb := sizeof(FrameInfo);
  IPSite.GetWindowContext(IPFrame, IPUIWindow, PosRect, ClipRect, FrameInfo);
  FillChar(omgw, SizeOf(omgw), 0);
  omgw[1] := 1;
  // Create a blank menu and ask the container to add it's menus into the
  // TOleMenuGroupWidths record
  FSharedMenu := CreateMenu;
  try
    OleCheck(IPFrame.InsertMenus(FSharedMenu, omgw));
    if FMenu = nil then Exit;
    MergeMenus(FSharedMenu, FMenu.Handle, @omgw.width, 1);
    // Send the menu to the client
    FOleMenu := OleCreateMenuDescriptor(FSharedMenu, omgw);
    IPFrame.SetMenu(FSharedMenu, FOleMenu, Control.Handle);
  except
    DestroyMenu(FSharedMenu);
    FSharedMenu := 0;
    raise;
  end;
end;

procedure TActiveXDocument.InPlaceMenuDestroy;
var
  IPFrame: IOleInPlaceFrame;
  IPSite: IOleInPlaceSite;
  IPUIWindow: IOleInPlaceUIWindow;
  FrameInfo: TOleInPlaceFrameInfo;
  PosRect, ClipRect: TRect;
begin
  // Get the clients IOleInPlaceFrame so we can ask it to remove it's menu
  OleCheck(ClientSite.QueryInterface(IOleInPlaceSite, IPSite));
  FrameInfo.cb := sizeof(FrameInfo);
  IPSite.GetWindowContext(IPFrame, IPUIWindow, PosRect, ClipRect, FrameInfo);
  if IPFrame <> nil then IPFrame.SetMenu(0, 0, 0);
  OleDestroyMenuDescriptor(FOleMenu);
  FOleMenu := 0;
  UnmergeMenus(FSharedMenu, FMenu.Handle);
end;

type
  PIntArray = ^TIntArray;
  TIntArray = array[0..0] of Integer;

procedure TActiveXDocument.MergeMenus(SharedMenu, SourceMenu: HMENU;
  MenuWidths: PInteger; WidthIndex: Integer);
var
  MenuItems, GroupWidth, Position, I, Len: Integer;
  MenuState: UINT;
  PopupMenu: HMENU;
  ItemText: array[0..255] of char;
begin
  // Copy the popups from the pMenuSource
  MenuItems := GetMenuItemCount(SourceMenu);
  GroupWidth := 0;
  Position := 0;
  // Insert at appropriate spot depending on WidthIndex
  if (WidthIndex < 0) or (WidthIndex > 1) then Exit;
  if WidthIndex = 1 then Position := MenuWidths^;
  for I := 0 to MenuItems - 1 do
  begin
    // Get the HMENU of the popup
    PopupMenu := GetSubMenu(SourceMenu, I);
    // Separators move us to next group
    MenuState := GetMenuState(SourceMenu, I, MF_BYPOSITION);
    if (PopupMenu = NULL) and ((MenuState and MF_SEPARATOR) <> 0) then
    begin
      if WidthIndex > 5 then Exit;     // Servers should not touch past 5
      PIntArray(MenuWidths)^[WidthIndex] := GroupWidth;
      GroupWidth := 0;
      if WidthIndex < 5 then
        Inc(Position, PIntArray(MenuWidths)^[WidthIndex + 1]);
      Inc(WidthIndex, 2);
    end
    else begin
      // Get the menu item text
      Len := GetMenuString(SourceMenu, I, ItemText, SizeOf(ItemText), MF_BYPOSITION);
      // Popups are handled differently than normal menu items
      if PopupMenu <> 0 then
      begin
        if GetMenuItemCount(PopupMenu) <> 0 then
        begin
          // Strip the HIBYTE because it contains a count of items
          MenuState := LoByte(MenuState) or MF_POPUP;   // Must be popup
          // Non-empty popup -- add it to the shared menu bar
          InsertMenu(SharedMenu, Position, MenuState or MF_BYPOSITION, PopupMenu,
            ItemText);
          Inc(Position);
          Inc(GroupWidth);
        end;
      end
      else if Len > 0 then
      begin
        // only non-empty items are added
        if ItemText <> '' then
        begin
          // here the state does not contain a count in the HIBYTE
          InsertMenu(SharedMenu, Position, MenuState or MF_BYPOSITION,
            GetMenuItemID(SourceMenu, I), ItemText);
          Inc(Position);
          Inc(GroupWidth);
        end;
      end;
    end;
  end;
end;

procedure TActiveXDocument.UnmergeMenus(SharedMenu, SourceMenu: HMENU);
var
  TheseItems, MenuItems, I, J: Integer;
  PopupMenu: HMENU;
begin
  MenuItems := GetMenuItemCount(SharedMenu);
  TheseItems := GetMenuItemCount(SourceMenu);
  for I := MenuItems - 1 downto 0 do
  begin
    // Check the popup menus
    PopupMenu := GetSubMenu(SharedMenu, I);
    if PopupMenu <> 0 then
    begin
      // If it is one of ours, remove it from the SharedMenu
      for J := 0 to TheseItems - 1 do
      begin
        if GetSubMenu(SourceMenu, J) = PopupMenu then
        begin
          // Remove the menu from SharedMenu
          RemoveMenu(SharedMenu, I, MF_BYPOSITION);
          Break;
        end;
      end;
    end;
  end;
end;

{ TActiveXDocument.IOleDocument }

function TActiveXDocument.CreateView(Site: IOleInPlaceSite;
  Stream: IStream; rsrvd: DWORD; out View: IOleDocumentView): HResult;
var
  OleDocView: IOleDocumentView;
begin
  Result := S_OK;
  try
    if View = nil then
    begin
      Result := E_POINTER;
      Exit;
    end;
    OleDocView := Self as IOleDocumentView;
    if (OleInPlaceSite = nil) or (OleDocView = nil) then
    begin
      Result := E_FAIL;
      Exit;
    end;
    // Use site provided
    if Site <> nil then OleDocView.SetInPlaceSite(Site);
    // Use stream provided for initialization
    if Stream <> nil then OleDocView.ApplyViewState(Stream);
    // Return the view
    View := OleDocView;
  except
    Result := E_FAIL;
  end;
end;

function TActiveXDocument.EnumViews(out Enum: IEnumOleDocumentViews;
  out View: IOleDocumentView): HResult;
begin
  Result := S_OK;
  try
    // We only support one view
    View := Self as IOleDocumentView;
  except
    Result := E_FAIL;
  end;
end;

function TActiveXDocument.GetDocMiscStatus(var Status: DWORD): HResult;
begin
  Status := (Factory as TActiveXDocumentFactory).DocMiscStatus;
  Result := S_OK;
end;

{ TActiveXDocument.IOleDocument }

function TActiveXDocument.ApplyViewState(pstm: IStream): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveXDocument.Clone(NewSite: IOleInPlaceSite;
  out NewView: IOleDocumentView): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveXDocument.CloseView(dwReserved: DWORD): HResult;
begin
  Result := S_OK;
  try
    Show(False);
    SetInPlaceSite(nil);
  except
    Result := E_UNEXPECTED;
  end;
end;

function TActiveXDocument.GetDocument(out P: IUnknown): HResult;
begin
  Result := S_OK;
  try
    P := Self as IUnknown;
  except
    Result := E_FAIL;
  end;
end;

function TActiveXDocument.GetInPlaceSite(out Site: IOleInPlaceSite): HResult;
begin
  Result := S_OK;
  try
    Site := OleInPlaceSite;
  except
    Result := E_FAIL;
  end;
end;

function TActiveXDocument.GetRect(var View: TRECT): HResult;
begin
  Result := S_OK;
  try
    View := Control.BoundsRect;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TActiveXDocument.Open: HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveXDocument.SaveViewState(pstm: IStream): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveXDocument.SetInPlaceSite(Site: IOleInPlaceSite): HResult;
begin
  Result := S_OK;
  try
    if OleInPlaceSite <> nil then
      Result := InPlaceDeactivate;
    if Result <> S_OK then Exit;
    if Site <> nil then OleInPlaceSite := Site;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TActiveXDocument.SetRect(const View: TRECT): HResult;
begin
  // Implement using TActiveXControl's IOleInPlaceObject.SetObjectRects impl
  Result := SetObjectRects(View, View);
end;

function TActiveXDocument.SetRectComplex(const View; const HScroll;
  const VScroll; const SizeBox): HResult;
begin
  Result := E_NOTIMPL;
end;

function TActiveXDocument.Show(fShow: BOOL): HResult;
begin
  try
    if fShow then
      Result := InPlaceActivate(False)
    else begin
      Result := UIActivate(False);
      Control.Visible := False;
    end;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TActiveXDocument.UIActivate(fUIActivate: BOOL): HResult;
begin
  Result := S_OK;
  try
    if FUIActivate then
    begin
      if OleInPlaceSite <> nil then InPlaceActivate(True)
      else Result := E_UNEXPECTED;
    end
    else begin
      UIDeactivate;
      InPlaceMenuDestroy;
    end;
  except
    Result := E_UNEXPECTED;
  end;
end;

{ TActiveXDocument.IOleInPlaceActiveObject }

function TActiveXDocument.OnDocWindowActivate(fActivate: BOOL): HResult;
begin
  Result := inherited OnDocWindowActivate(fActivate);
  if fActivate then InPlaceMenuCreate
  else InPlaceMenuDestroy;
end;

{ TActiveXDocument.IOleInPlaceObject }

function TActiveXDocument.InPlaceDeactivate: HResult;
var
  ParentWnd: HWND;
begin
  // This is a work-around for the fact that TActiveXControl implementation of
  // this method makes the control go away to ParkingWindow la-la land.  It
  // needs to stay put within the document.
  ParentWnd := Control.ParentWindow;
  Result := inherited InplaceDeactivate;
  Control.ParentWindow := ParentWnd;
  Control.Visible := True;
end;

{ TActiveXDocumentFactory }

constructor TActiveXDocumentFactory.Create(ComServer: TComServerObject;
  ActiveXDocClass: TActiveXDocClass; WinControlClass: TWinControlClass;
  const ClassID: TGUID; ToolboxBitmapID, MiscStatus: Integer;
  ThreadingModel: TThreadingModel; const Handler: string;
  DocMiscStatus: DWORD);
begin
  FDocMiscStatus := DocMiscStatus;
  if Handler <> '' then FHandler := Handler
  else FHandler := 'ole32.dll';
  inherited Create(ComServer, ActiveXDocClass, WinControlClass, ClassId,
    ToolboxBitmapID, '', MiscStatus, ThreadingModel);
end;

procedure TActiveXDocumentFactory.UpdateRegistry(Register: Boolean);
var
  ClassKey, ProgKey, MiscFlags: string;
begin
  ClassKey := 'CLSID\' + GUIDToString(ClassID) + '\';
  ProgKey := ProgID + '\';
  if Register then
  begin
    inherited UpdateRegistry(Register);
    MiscFlags := IntToStr(FDocMiscStatus);
    // Add reg keys under CLSID
    CreateRegKey(ClassKey + 'DocObject', '', MiscFlags);
    CreateRegKey(ClassKey + 'Programmable', '', '');
    CreateRegKey(ClassKey + 'Insertable', '', '');
    CreateRegKey(ClassKey + 'InprocHandler32', '', FHandler);
    // Add reg keys under ProgID
    CreateRegKey(ProgKey + 'DocObject', '', MiscFlags);
    CreateRegKey(ProgKey + 'Insertable', '', '');
    // Need to remove "control" key added by inherited method
    DeleteRegKey(ClassKey + 'Control');
  end
  else begin
    DeleteRegKey(ClassKey + 'DefaultExtension');
    DeleteRegKey(ClassKey + 'DefaultIcon');
    DeleteRegKey(ClassKey + 'DocObject');
    DeleteRegKey(ClassKey + 'Programmable');
    DeleteRegKey(ClassKey + 'Insertable');
    DeleteRegKey(ClassKey + 'InprocHandler32');
    DeleteRegKey(ProgKey + 'DocObject');
    DeleteRegKey(ProgKey + 'Insertable');
    inherited UpdateRegistry(Register);
  end;
end;

end.